Visual Basic Toolbox

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / internet / appc / ping.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1995-11-12 | 29.9 KB | 878 lines

VERSION 2.00 Begin Form frmPing BackColor = &H00FFFFFF& BorderStyle = 3 'Fixed Double Caption = "Ping!" ClientHeight = 4890 ClientLeft = 2475 ClientTop = 1305 ClientWidth = 4515 FillColor = &H0000FF00& FillStyle = 0 'Solid Height = 5295 Icon = PING.FRX:0000 Left = 2415 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False Picture = PING.FRX:0302 ScaleHeight = 326 ScaleMode = 3 'Pixel ScaleWidth = 301 Top = 960 Width = 4635 Begin CommandButton cmdExit Cancel = -1 'True Caption = "E&xit" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 3360 TabIndex = 1 Top = 4440 Width = 975 End Begin CommandButton cmdPing Caption = "&Ping" Default = -1 'True FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 2280 TabIndex = 0 Top = 4440 Width = 975 End Begin Frame fraTrans BackColor = &H00FFFFFF& Caption = "Transaction Options" Height = 3195 Left = 2220 TabIndex = 23 Top = 1200 Width = 2175 Begin TextBox txtAttempts FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 285 Left = 960 TabIndex = 17 TabStop = 0 'False Top = 1800 Width = 735 End Begin TextBox txtSend FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 285 Left = 60 TabIndex = 15 Text = "a" Top = 1260 Width = 735 End Begin TextBox txtReceived FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 285 Left = 60 TabIndex = 16 Top = 1800 Width = 735 End Begin TextBox txtBufSize FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 285 Left = 60 TabIndex = 13 Text = "271" Top = 480 Width = 795 End Begin CheckBox chkConfirm BackColor = &H00FFFFFF& Caption = "Enable Confirmation" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Left = 60 TabIndex = 14 Top = 780 Width = 1815 End Begin Shape shpReset BackColor = &H00FFFFFF& FillColor = &H00FFFFFF& FillStyle = 0 'Solid Height = 195 Left = 60 Shape = 3 'Circle Top = 2400 Width = 135 End Begin Label zlbl BackColor = &H00FFFFFF& Caption = "Reset State" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 1 Left = 240 TabIndex = 30 Top = 2400 Width = 915 End Begin Label zlbl BackColor = &H00FFFFFF& Caption = "Partner Wishes To Send" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 3 Left = 240 TabIndex = 27 Top = 2880 Width = 1875 End Begin Shape shpPartnerWishesToSend BackColor = &H00FFFFFF& FillColor = &H00FFFFFF& FillStyle = 0 'Solid Height = 195 Left = 60 Shape = 3 'Circle Top = 2880 Width = 135 End Begin Label zlbl BackColor = &H00FFFFFF& Caption = "Receive State" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 0 Left = 240 TabIndex = 29 Top = 2160 Width = 1215 End Begin Shape shpReceiving BackColor = &H00FFFFFF& FillColor = &H00FFFFFF& FillStyle = 0 'Solid Height = 195 Left = 60 Shape = 3 'Circle Top = 2160 Width = 135 End Begin Label zlbl BackColor = &H00FFFFFF& Caption = "Send State" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 2 Left = 240 TabIndex = 28 Top = 2640 Width = 915 End Begin Shape shpSending BackColor = &H00FFFFFF& FillColor = &H00FFFFFF& FillStyle = 0 'Solid Height = 195 Left = 60 Shape = 3 'Circle Top = 2640 Width = 135 End Begin Label zlbl BackColor = &H00FFFFFF& Caption = "Attempts:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00000000& Height = 195 Index = 4 Left = 960 TabIndex = 26 Top = 1620 Width = 795 End Begin Label zlbl BackColor = &H00FFFFFF& Caption = "Send:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00000000& Height = 195 Index = 6 Left = 60 TabIndex = 18 Top = 1080 Width = 795 End Begin Label zlbl BackColor = &H00FFFFFF& Caption = "Received:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00000000& Height = 195 Index = 5 Left = 60 TabIndex = 19 Top = 1620 Width = 795 End Begin Label zlbl BackColor = &H00FFFFFF& Caption = "Buffer Size:" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00000000& Height = 195 Index = 7 Left = 60 TabIndex = 24 Top = 300 Width = 975 End End Begin Frame fraPing BackColor = &H00FFFFFF& Caption = "Ping Options" Height = 3615 Left = 120 TabIndex = 22 Top = 1200 Width = 2055 Begin CheckBox chkPing BackColor = &H00FFFFFF& Caption = "Receive" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 5 Left = 60 TabIndex = 5 Top = 1800 Value = 1 'Checked Width = 1395 End Begin CheckBox chkPing BackColor = &H00FFFFFF& Caption = "Request To Send" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 8 Left = 60 TabIndex = 10 Top = 2700 Width = 1755 End Begin CheckBox chkPing BackColor = &H00FFFFFF& Caption = "Query State" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 7 Left = 60 TabIndex = 9 Top = 2400 Width = 1755 End Begin CheckBox chkPing BackColor = &H00FFFFFF& Caption = "Prepare To Receive" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 4 Left = 60 TabIndex = 4 Top = 1500 Value = 1 'Checked Width = 1755 End Begin CheckBox chkPing BackColor = &H00FFFFFF& Caption = "Flush Buffer" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 3 Left = 60 TabIndex = 8 Top = 1200 Width = 1515 End Begin CheckBox chkPing BackColor = &H00FFFFFF& Caption = "Send Confirm Reply" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 6 Left = 60 TabIndex = 7 Top = 2100 Width = 1935 End Begin CheckBox chkPing BackColor = &H00FFFFFF& Caption = "Send Error" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 9 Left = 60 TabIndex = 11 Top = 3000 Width = 1335 End Begin CheckBox chkPing BackColor = &H00FFFFFF& Caption = "Allocate" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 0 Left = 60 TabIndex = 2 Top = 300 Value = 1 'Checked Width = 975 End Begin CheckBox chkPing BackColor = &H00FFFFFF& Caption = "Send" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 1 Left = 60 TabIndex = 3 Top = 600 Value = 1 'Checked Width = 1395 End Begin CheckBox chkPing BackColor = &H00FFFFFF& Caption = "Deallocate" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 10 Left = 60 TabIndex = 12 Top = 3300 Value = 1 'Checked Width = 1155 End Begin CheckBox chkPing BackColor = &H00FFFFFF& Caption = "Request Confirm" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Index = 2 Left = 60 TabIndex = 6 Top = 900 Value = 1 'Checked Width = 1515 End End Begin Label lblMsg BackStyle = 0 'Transparent FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 255 Left = 60 TabIndex = 25 Top = 120 Width = 3435 End Begin Label lblPC BackColor = &H00FFFFFF& Caption = "PC" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H000000FF& Height = 255 Left = 120 TabIndex = 21 Top = 1020 Width = 1185 End Begin Label lblSystem Alignment = 1 'Right Justify BackColor = &H00FFFFFF& Caption = "AS/400" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00FF0000& Height = 255 Left = 1470 TabIndex = 20 Top = 1020 Width = 2925 End Begin Image imgPingBack Height = 480 Left = 3300 Picture = PING.FRX:5944 Top = 450 Visible = 0 'False Width = 210 End Begin Image imgPingOut Height = 240 Left = 570 Picture = PING.FRX:5F7E Top = 570 Visible = 0 'False Width = 240 End Option Explicit ' Constants: Const nTRAN_SIZE = 1 ' transaction size ' Variables: Dim bCAPartnerWishesToSend As Integer ' partner wishes to send Dim lCAConvId As Long ' conversation ID Dim nCArc As Integer ' API return code Dim nCAReadAttempts As Integer ' number of read attempts Dim nCASyncLvl As Integer ' synchronization level Dim nCAWhatRcvd As Integer ' what is being sent back Dim nPartnerMAX As Integer ' maximum read attempts Dim nRC As Integer ' return code Dim sCAData As String ' data Dim sCADataBlock As String ' data block Dim sCALocalLU As String ' local LU ("PC") name Dim sCAModeName As String ' mode name ("QPCSUPP") Dim sCASystem As String ' AS/400 name Dim sCAUserID As String ' AS/400 user ID Dim sPartnerICF As String ' ICF program device Dim sPartnerLIB As String ' partner library Dim sPartnerPGM As String ' partner program Dim sPartnerSYS As String ' partner system Sub cmdExit_Click () Unload Me End Sub Sub cmdPing_Click () ' Description: ' PING ' Variables: Dim sPIP As String ' allocate PIP string ReDim asPIP(1 To 1) As String ' PIP parameters ' clear any previous ' messages and indicators lblMsg = gsEMPTY nCArc = 0 ' do audio and graphics ' for PING out from PC Call PingOut ' if allocating and no active conversation then If chkPing(0).Value = CHECKED And lCAConvId = 0 Then ' format PIP data asPIP(1) = Left$(sPartnerICF & Space$(10), 10) sPIP = zzCAFormattedPIP(Me.hWnd, asPIP()) ' allocate ("start") the conversation ' without or with confirmation enabled If chkConfirm = False Then lCAConvId = zzCAConvStart(Me.hWnd, Val(txtBufSize), sPartnerSYS, sPartnerLIB & "/" & sPartnerPGM, sPIP, nCArc) Else lCAConvId = zzCAConvStartConfirm(Me.hWnd, Val(txtBufSize), sPartnerSYS, sPartnerLIB & "/" & sPartnerPGM, sPIP, nCArc) End If ' update flags Call SetStateAndSendFlags ' if error then exit routine If lCAConvId = 0 Then Exit Sub ' query conversation attributes nCArc = zzCAQueryAttributes(Me.hWnd, lCAConvId, nCASyncLvl, sCAModeName, sCALocalLU, sCASystem, sCAUserID) ' update local lu name lblPC = sCALocalLU ' turn off allocate option chkPing(0).Value = UNCHECKED chkPing(0).Enabled = False End If ' if sending then If chkPing(1).Value = CHECKED Then ' convert to EBCDIC sCAData = zzCV_ASCIItoEBCDIC(Me.hWnd, String$(nTRAN_SIZE, txtSend)) ' send data nCArc = zzCASend(Me.hWnd, lCAConvId, sCAData, nTRAN_SIZE, bCAPartnerWishesToSend) ' update flags Call SetStateAndSendFlags End If ' if sending confirmation request If chkPing(2).Value = CHECKED Then ' send confirmation request nCArc = zzCASendConfirmRequest(Me.hWnd, lCAConvId, bCAPartnerWishesToSend) ' update flags Call SetStateAndSendFlags End If ' if flushing buffer then If chkPing(3).Value = CHECKED Then ' flush buffer nCArc = zzCAFlush(Me.hWnd, lCAConvId) ' update flags Call SetStateAndSendFlags End If ' if preparing to receive then If chkPing(4).Value = CHECKED Then ' prepare to receive nCArc = zzCATellReadyToReceive(Me.hWnd, lCAConvId) ' update flags Call SetStateAndSendFlags End If ' if receiving then If chkPing(5).Value = CHECKED Then ' clear fields txtReceived = gsEMPTY ' value returned sCADataBlock = gsEMPTY ' clear block nCAReadAttempts = 0 ' counter txtAttempts.Text = "0" ' counter label Do ' receive data nCArc = zzCAReceive(Me.hWnd, lCAConvId, nTRAN_SIZE, sCAData, nCAWhatRcvd, bCAPartnerWishesToSend) ' increment counter of read attempts nCAReadAttempts = nCAReadAttempts + 1 txtAttempts.Text = Format$(nCAReadAttempts) If nCAReadAttempts > nPartnerMAX Then Exit Do ' give windows time DoEvents ' if error on receipt of data If nCArc <> gnCA_OK Then ' if not "unsuccessful read" then update message If nCArc <> gnCA_UNSUCCESSFUL Then Exit Do ' if no error Else ' if send requested by partner ' this signals end of transmission If nCAWhatRcvd = gnCA_RCVD_SEND Then ' remove headers from data sCADataBlock = zzCARemoveHeadersFromBlock(sCADataBlock, nTRAN_SIZE) ' convert to ASCII sCADataBlock = zzCV_EBCDICtoASCII(Me.hWnd, sCADataBlock) ' leave loop Exit Do ' add what returned to data block Else sCADataBlock = sCADataBlock & sCAData End If End If Loop ' place data into text box txtReceived = sCADataBlock ' update flags Call SetStateAndSendFlags End If ' if answering confirmation request If chkPing(6).Value = CHECKED Then ' reply to confirmation request nCArc = zzCASendConfirmReply(Me.hWnd, lCAConvId) ' update flags Call SetStateAndSendFlags End If ' if querying state then If chkPing(7).Value = CHECKED Then ' show message box that description state of conversation MsgBox zzCAGetStateText(zzCAQueryState(Me.hWnd, lCAConvId), True), MB_ICONINFORMATION End If ' if requesting to send then If chkPing(8).Value = CHECKED Then ' request to send nCArc = zzCATellWantToSend(Me.hWnd, lCAConvId) ' update flags Call SetStateAndSendFlags End If ' if sending error indication If chkPing(9).Value = CHECKED Then ' send error nCArc = zzCASendError(Me.hWnd, lCAConvId, bCAPartnerWishesToSend) ' update flags Call SetStateAndSendFlags End If ' if deallocating and active conversation If chkPing(10).Value = CHECKED Then ' end conversation nCArc = zzCAConvStopConfirm(Me.hWnd, lCAConvId, True) ' update flags Call SetStateAndSendFlags ' if any unexpected error then exit routine If nCArc <> gnCA_OK And nCArc <> gnCA_DEALLOC_ABEND_PROGRAM Then Exit Sub ' no more active conversation lCAConvId = 0 ' turn on allocate option chkPing(0).Value = CHECKED chkPing(0).Enabled = True End If ' do audio and graphics ' for PING out from AS/400 ' if no errors occurred If lblMsg = gsEMPTY Then Call PingBack End Sub Sub Form_Load () ' setup globals Call zzSetGlobalVariables ' center form zzFormCenter Me ' setup title App.Title = Caption ' setup INI file and section nRC = zzINISetFile(App.Path & "\APPC.INI") nRC = zzINISetSection("PING") ' get AS/400 system nRC = zzINIGetString("System", sPartnerSYS) ' get AS/400 library nRC = zzINIGetString("Library", sPartnerLIB) ' get AS/400 program nRC = zzINIGetString("Program", sPartnerPGM) ' get AS/400 ICF device nRC = zzINIGetString("Device", sPartnerICF) ' get maximum read attempts nRC = zzINIGetInteger("MaxAttempts", nPartnerMAX) If sPartnerSYS = gsEMPTY Then MsgBox "AS/400 system reference invalid. Check APPC.INI file for proper values." End ElseIf sPartnerLIB = gsEMPTY Then MsgBox "AS/400 library reference invalid. Check APPC.INI file for proper values." End ElseIf sPartnerPGM <> "PINGRPG" Then MsgBox "AS/400 program reference invalid. Check APPC.INI file for proper values." End ElseIf sPartnerICF <> "PINGICF" Then MsgBox "AS/400 ICF device reference invalid. Check APPC.INI file for proper values." End ElseIf nPartnerMAX = 0 Then MsgBox "APPC retry attempts setting invalid. Check APPC.INI file for proper values." End End If ' display information lblSystem = sPartnerSYS & "/" & sPartnerLIB & "/" & sPartnerPGM ' no active conversation lCAConvId = 0 ' if router not loaded then If Not zzCARouterLoaded(Me.hWnd) Then ' tell user of error lblMsg = zzCAGetRCText(gnCA_ROUTER_NOT_INSTALLED, True) End If End Sub Sub Form_Unload (Cancel As Integer) ' if active conversation If lCAConvId <> 0 Then ' end conversation nCArc = zzCAConvStopConfirm(Me.hWnd, lCAConvId, True) ' if conversation not ended If nCArc <> gnCA_OK Then MsgBox zzCAGetRCText(nCArc, True), MB_ICONSTOP End If ' end program End End Sub Sub PingBack () ' Description: ' Do audio and graphics stuff ' that show a PING going from ' AS/400 to PC. ' Variables: Dim nLoc As Integer imgPingBack.Top = 30 imgPingBack.Left = 220 imgPingBack.Visible = True For nLoc = 218 To 34 Step -2 imgPingBack.Left = nLoc Next nLoc imgPingBack.Visible = False nLoc = zzWAVPlay(App.Path & "\pingbck.wav") End Sub Sub PingOut () ' Description: ' Do audio and graphics stuff ' that show a PING going from ' PC to AS/400. ' Variables: Dim nLoc As Integer imgPingOut.Top = 38 imgPingOut.Left = 38 imgPingOut.Visible = True nLoc = zzWAVPlay(App.Path & "\pingout.wav") For nLoc = 40 To 218 Step 2 imgPingOut.Left = nLoc Next nLoc imgPingOut.Visible = False End Sub Sub SetStateAndSendFlags () ' Description: ' Set SEND and RECEIVE state flags ' and whether the partner wishes to send ' update message lblMsg = zzCAGetRCText(nCArc, True) ' is the conversation in RESET state If zzCAQueryAmIReset(Me.hWnd, lCAConvId) Then shpReset.FillColor = YELLOW Else shpReset.FillColor = WHITE End If ' is the conversation in SEND state If zzCAQueryAmISending(Me.hWnd, lCAConvId) Then shpSending.FillColor = GREEN Else shpSending.FillColor = WHITE End If ' is the conversation in RECEIVE state If zzCAQueryAmIReceiving(Me.hWnd, lCAConvId) Then shpReceiving.FillColor = RED Else shpReceiving.FillColor = WHITE End If ' has partner sent a REQUEST TO SEND If bCAPartnerWishesToSend Then shpPartnerWishesToSend.FillColor = BLACK Else shpPartnerWishesToSend.FillColor = WHITE End If End Sub Sub txtAttempts_GotFocus () SendKeys "{TAB}" End Sub Sub txtBufSize_LostFocus () ' make sure a number txtBufSize = Format$(Val(txtBufSize)) If txtBufSize = "0" Then txtBufSize = "271" End Sub Sub txtReceived_GotFocus () ' can't stop here SendKeys "{Tab}" End Sub Sub txtSend_Change () ' one letter upper case allowed txtSend = LCase$(Left$(txtSend, nTRAN_SIZE)) End Sub